home *** CD-ROM | disk | FTP | other *** search
/ L' Effet Pommier 3 / L'Effet Pommier - Volume 03.iso / Programmation / Alpha ƒ / Tcl / UserCode / Text Filters / Unix / s2p
Text File  |  1994-03-07  |  14KB  |  754 lines
  1. $bin = '/usr/local/bin';
  2.  
  3. # $RCSfile: s2p.SH,v $$Revision: 4.0.1.1 $$Date: 91/06/07 12:19:18 $
  4. #
  5. # $Log:    s2p.SH,v $
  6. # Revision 4.0.1.1  91/06/07  12:19:18  lwall
  7. # patch4: s2p now handles embedded newlines better and optimizes common idioms
  8. # 
  9. # Revision 4.0  91/03/20  01:57:59  lwall
  10. # 4.0 baseline.
  11. # 
  12. #-----------------------------------------------------------------
  13. # modified 2/94 by Tom Pollard <pollard@chem.columbia.edu>
  14. #
  15. # This version operates without writing to disk or calling the 
  16. # C preprocessor, making it usable with the standalone version of
  17. # MacPerl.
  18. #-----------------------------------------------------------------
  19.  
  20. $indent = 4;
  21. $shiftwidth = 4;
  22. $l = '{'; $r = '}';
  23.  
  24. $BODY = "" ;
  25.  
  26. while ($ARGV[0] =~ /^-/) {
  27.     $_ = shift;
  28.   last if /^--/;
  29. #    if (/^-D/) {
  30. #    $debug++;
  31. #    open(BODY,'>-');
  32. #    next;
  33. #    }
  34.     if (/^-n/) {
  35.     $assumen++;
  36.     next;
  37.     }
  38.     if (/^-p/) {
  39.     $assumep++;
  40.     next;
  41.     }
  42.     die "I don't recognize this switch: $_\n";
  43. }
  44.  
  45. if (!$assumen && !$assumep) {
  46.     $BODY .= &q(<<'EOT');
  47. :    while ($ARGV[0] =~ /^-/) {
  48. :        $_ = shift;
  49. :      last if /^--/;
  50. :        if (/^-n/) {
  51. :        $nflag++;
  52. :        next;
  53. :        }
  54. :        die "I don't recognize this switch: $_\\n";
  55. :    }
  56. :    
  57. EOT
  58. }
  59.  
  60. $BODY .= &q(<<'EOT');
  61. :    #ifdef PRINTIT
  62. :    #ifdef ASSUMEP
  63. :    $printit++;
  64. :    #else
  65. :    $printit++ unless $nflag;
  66. :    #endif
  67. :    #endif
  68. :    <><>
  69. :    $\ = "\n";        # automatically add newline on print
  70. :    <><>
  71. :    #ifdef TOPLABEL
  72. :    LINE:
  73. :    while (chop($_ = <>)) {
  74. :    #else
  75. :    LINE:
  76. :    while (<>) {
  77. :        chop;
  78. :    #endif
  79. EOT
  80.  
  81. LINE:
  82. while (<>) {
  83.  
  84.     # Wipe out surrounding whitespace.
  85.  
  86.     s/[ \t]*(.*)\n$/$1/;
  87.  
  88.     # Perhaps it's a label/comment.
  89.  
  90.     if (/^:/) {
  91.     s/^:[ \t]*//;
  92.     $label = &make_label($_);
  93.     if ($. == 1) {
  94.         $toplabel = $label;
  95.         if (/^(top|(re)?start|redo|begin(ning)|again|input)$/i) {
  96.         $_ = <>;
  97.         redo LINE; # Never referenced, so delete it if not a comment.
  98.         }
  99.     }
  100.     $_ = "$label:";
  101.     if ($lastlinewaslabel++) {
  102.         $indent += 4;
  103.         $BODY .= &tab.";\n";
  104.         $indent -= 4;
  105.     }
  106.     if ($indent >= 2) {
  107.         $indent -= 2;
  108.         $indmod = 2;
  109.     }
  110.     next;
  111.     } else {
  112.     $lastlinewaslabel = '';
  113.     }
  114.  
  115.     # Look for one or two address clauses
  116.  
  117.     $addr1 = '';
  118.     $addr2 = '';
  119.     if (s/^([0-9]+)//) {
  120.     $addr1 = "$1";
  121.     $addr1 = "\$. == $addr1" unless /^,/;
  122.     }
  123.     elsif (s/^\$//) {
  124.     $addr1 = 'eof()';
  125.     }
  126.     elsif (s|^/||) {
  127.     $addr1 = &fetchpat('/');
  128.     }
  129.     if (s/^,//) {
  130.     if (s/^([0-9]+)//) {
  131.         $addr2 = "$1";
  132.     } elsif (s/^\$//) {
  133.         $addr2 = "eof()";
  134.     } elsif (s|^/||) {
  135.         $addr2 = &fetchpat('/');
  136.     } else {
  137.         &Die("Invalid second address at line $.\n");
  138.     }
  139.     $addr1 .= " .. $addr2";
  140.     }
  141.  
  142.     # Now we check for metacommands {, }, and ! and worry
  143.     # about indentation.
  144.  
  145.     s/^[ \t]+//;
  146.     # a { to keep vi happy
  147.     if ($_ eq '}') {
  148.     $indent -= 4;
  149.     next;
  150.     }
  151.     if (s/^!//) {
  152.     $if = 'unless';
  153.     $else = "$r else $l\n";
  154.     } else {
  155.     $if = 'if';
  156.     $else = '';
  157.     }
  158.     if (s/^{//) {    # a } to keep vi happy
  159.     $indmod = 4;
  160.     $redo = $_;
  161.     $_ = '';
  162.     $rmaybe = '';
  163.     } else {
  164.     $rmaybe = "\n$r";
  165.     if ($addr2 || $addr1) {
  166.         $space = ' ' x $shiftwidth;
  167.     } else {
  168.         $space = '';
  169.     }
  170.     $_ = &transmogrify();
  171.     }
  172.  
  173.     # See if we can optimize to modifier form.
  174.  
  175.     if ($addr1) {
  176.     if ($_ !~ /[\n{}]/ && $rmaybe && !$change &&
  177.       $_ !~ / if / && $_ !~ / unless /) {
  178.         s/;$/ $if $addr1;/;
  179.         $_ = substr($_,$shiftwidth,1000);
  180.     } else {
  181.         $_ = "$if ($addr1) $l\n$change$_$rmaybe";
  182.     }
  183.     $change = '';
  184.     next LINE;
  185.     }
  186. } continue {
  187.     @lines = split(/\n/,$_);
  188.     for (@lines) {
  189.     unless (s/^ *<<--//) {
  190.         $BODY .= &tab;
  191.     }
  192.     $BODY .= $_."\n";
  193.     }
  194.     $indent += $indmod;
  195.     $indmod = 0;
  196.     if ($redo) {
  197.     $_ = $redo;
  198.     $redo = '';
  199.     redo LINE;
  200.     }
  201. }
  202. if ($lastlinewaslabel++) {
  203.     $indent += 4;
  204.     $BODY .= &tab.";\n";
  205.     $indent -= 4;
  206. }
  207.  
  208. if ($appendseen || $tseen || !$assumen) {
  209.     $printit++ if $dseen || (!$assumen && !$assumep);
  210.     $BODY .= &q(<<'EOT');
  211. :    #ifdef SAWNEXT
  212. :    }
  213. :    continue {
  214. :    #endif
  215. :    #ifdef PRINTIT
  216. :    #ifdef DSEEN
  217. :    #ifdef ASSUMEP
  218. :        print if $printit++;
  219. :    #else
  220. :        if ($printit)
  221. :        { print; }
  222. :        else
  223. :        { $printit++ unless $nflag; }
  224. :    #endif
  225. :    #else
  226. :        print if $printit;
  227. :    #endif
  228. :    #else
  229. :        print;
  230. :    #endif
  231. :    #ifdef TSEEN
  232. :        $tflag = 0;
  233. :    #endif
  234. :    #ifdef APPENDSEEN
  235. :        if ($atext) { chop $atext; print $atext; $atext = ''; }
  236. :    #endif
  237. EOT
  238.  
  239. $BODY .= &q(<<'EOT');
  240. :    }
  241. EOT
  242. }
  243.  
  244. unless ($debug) {
  245.     
  246.     $HEAD = "\n";
  247.     $HEAD .= "#define PRINTIT\n"    if $printit;
  248.     $HEAD .= "#define APPENDSEEN\n"    if $appendseen;
  249.     $HEAD .= "#define TSEEN\n"    if $tseen;
  250.     $HEAD .= "#define DSEEN\n"    if $dseen;
  251.     $HEAD .= "#define ASSUMEN\n"    if $assumen;
  252.     $HEAD .= "#define ASSUMEP\n"    if $assumep;
  253.     $HEAD .= "#define TOPLABEL\n"    if $toplabel;
  254.     $HEAD .= "#define SAWNEXT\n"    if $sawnext;
  255.  
  256.     if ($opens) {$HEAD .= "$opens\n";}
  257.  
  258.     @LINES = split(/^/,$HEAD.$BODY) ;    
  259.     
  260. #
  261. #  A very simple substitute for the C preprocessor
  262. #
  263. #  This code only interprets #define, #ifdef, #else, and #endif.
  264. #
  265. #  It can be used to process the output of the s2p (sed-to-perl) script.
  266. #
  267. #   2/19/94 : by Tom Pollard <pollard@chem.columbia.edu>
  268. #
  269.     $printit = 1;
  270.     $defs{"EMPTY"} = 0;
  271.  
  272.     foreach (@LINES) {
  273.      if (/^#define\s+(\w+)/) { 
  274.         $defs{$1} = $1 ; 
  275.         }
  276.      elsif (/^#ifdef\s+(\w+)/)  {
  277.         push(@printstack,$printit) ;
  278.         if ($defs{$1}) { push(@ifstack,0) ; }
  279.                   else { push(@ifstack,$printit) ; $printit = 0 ; }
  280.         }
  281.      elsif (/^#else/)  {
  282.         $printit =  pop(@ifstack) ;
  283.         push(@ifstack,0) ; 
  284.         }
  285.      elsif (/^#endif/)  {
  286.         $printit = pop(@printstack) ;
  287.         pop(@ifstack) ; 
  288.         }
  289.      elsif (/^# [0-9]/) {
  290.         next ;
  291.         }
  292.      elsif (/^[ \t]*$/) {
  293.         next ;
  294.         }
  295.      elsif (/^<><>/) {
  296.         next ;
  297.         }
  298.      elsif ($printit) {
  299.         print STDOUT ;
  300.         }
  301.     }
  302. }
  303.  
  304. exit;
  305.  
  306. sub Die {
  307.     die $_[0];
  308. }
  309. sub tab {
  310.     "\t" x ($indent / 8) . ' ' x ($indent % 8);
  311. }
  312. sub make_filehandle {
  313.     local($_) = $_[0];
  314.     local($fname) = $_;
  315.     if (!$seen{$fname}) {
  316.     $_ = "FH_" . $_ if /^\d/;
  317.     s/[^a-zA-Z0-9]/_/g;
  318.     s/^_*//;
  319.     $_ = "\U$_";
  320.     if ($fhseen{$_}) {
  321.         for ($tmp = "a"; $fhseen{"$_$tmp"}; $a++) {}
  322.         $_ .= $tmp;
  323.     }
  324.     $fhseen{$_} = 1;
  325.     $opens .= &q(<<"EOT");
  326. :    open($_, '>$fname') || die "Can't create $fname: \$!";
  327. EOT
  328.     $seen{$fname} = $_;
  329.     }
  330.     $seen{$fname};
  331. }
  332.  
  333. sub make_label {
  334.     local($label) = @_;
  335.     $label =~ s/[^a-zA-Z0-9]/_/g;
  336.     if ($label =~ /^[0-9_]/) { $label = 'L' . $label; }
  337.     $label = substr($label,0,8);
  338.  
  339.     # Could be a reserved word, so capitalize it.
  340.     substr($label,0,1) =~ y/a-z/A-Z/
  341.       if $label =~ /^[a-z]/;
  342.  
  343.     $label;
  344. }
  345.  
  346. sub transmogrify {
  347.     {    # case
  348.     if (/^d/) {
  349.         $dseen++;
  350.         chop($_ = &q(<<'EOT'));
  351. :    <<--#ifdef PRINTIT
  352. :    $printit = 0;
  353. :    <<--#endif
  354. :    next LINE;
  355. EOT
  356.         $sawnext++;
  357.         next;
  358.     }
  359.  
  360.     if (/^n/) {
  361.         chop($_ = &q(<<'EOT'));
  362. :    <<--#ifdef PRINTIT
  363. :    <<--#ifdef DSEEN
  364. :    <<--#ifdef ASSUMEP
  365. :    print if $printit++;
  366. :    <<--#else
  367. :    if ($printit)
  368. :        { print; }
  369. :    else
  370. :        { $printit++ unless $nflag; }
  371. :    <<--#endif
  372. :    <<--#else
  373. :    print if $printit;
  374. :    <<--#endif
  375. :    <<--#else
  376. :    print;
  377. :    <<--#endif
  378. :    <<--#ifdef APPENDSEEN
  379. :    if ($atext) {chop $atext; print $atext; $atext = '';}
  380. :    <<--#endif
  381. :    $_ = <>;
  382. :    chop;
  383. :    <<--#ifdef TSEEN
  384. :    $tflag = 0;
  385. :    <<--#endif
  386. EOT
  387.         next;
  388.     }
  389.  
  390.     if (/^a/) {
  391.         $appendseen++;
  392.         $command = $space . "\$atext .= <<'End_Of_Text';\n<<--";
  393.         $lastline = 0;
  394.         while (<>) {
  395.         s/^[ \t]*//;
  396.         s/^[\\]//;
  397.         unless (s|\\$||) { $lastline = 1;}
  398.         s/^([ \t]*\n)/<><>$1/;
  399.         $command .= $_;
  400.         $command .= '<<--';
  401.         last if $lastline;
  402.         }
  403.         $_ = $command . "End_Of_Text";
  404.         last;
  405.     }
  406.  
  407.     if (/^[ic]/) {
  408.         if (/^c/) { $change = 1; }
  409.         $addr1 = 1 if $addr1 eq '';
  410.         $addr1 = '$iter = (' . $addr1 . ')';
  411.         $command = $space .
  412.           "    if (\$iter == 1) { print <<'End_Of_Text'; }\n<<--";
  413.         $lastline = 0;
  414.         while (<>) {
  415.         s/^[ \t]*//;
  416.         s/^[\\]//;
  417.         unless (s/\\$//) { $lastline = 1;}
  418.         s/'/\\'/g;
  419.         s/^([ \t]*\n)/<><>$1/;
  420.         $command .= $_;
  421.         $command .= '<<--';
  422.         last if $lastline;
  423.         }
  424.         $_ = $command . "End_Of_Text";
  425.         if ($change) {
  426.         $dseen++;
  427.         $change = "$_\n";
  428.         chop($_ = &q(<<"EOT"));
  429. :    <<--#ifdef PRINTIT
  430. :    $space\$printit = 0;
  431. :    <<--#endif
  432. :    ${space}next LINE;
  433. EOT
  434.         $sawnext++;
  435.         }
  436.         last;
  437.     }
  438.  
  439.     if (/^s/) {
  440.         $delim = substr($_,1,1);
  441.         $len = length($_);
  442.         $repl = $end = 0;
  443.         $inbracket = 0;
  444.         for ($i = 2; $i < $len; $i++) {
  445.         $c = substr($_,$i,1);
  446.         if ($c eq $delim) {
  447.             if ($inbracket) {
  448.             substr($_, $i, 0) = '\\';
  449.             $i++;
  450.             $len++;
  451.             }
  452.             else {
  453.             if ($repl) {
  454.                 $end = $i;
  455.                 last;
  456.             } else {
  457.                 $repl = $i;
  458.             }
  459.             }
  460.         }
  461.         elsif ($c eq '\\') {
  462.             $i++;
  463.             if ($i >= $len) {
  464.             $_ .= 'n';
  465.             $_ .= <>;
  466.             $len = length($_);
  467.             $_ = substr($_,0,--$len);
  468.             }
  469.             elsif (substr($_,$i,1) =~ /^[n]$/) {
  470.             ;
  471.             }
  472.             elsif (!$repl &&
  473.               substr($_,$i,1) =~ /^[(){}\w]$/) {
  474.             $i--;
  475.             $len--;
  476.             substr($_, $i, 1) = '';
  477.             }
  478.             elsif (!$repl &&
  479.               substr($_,$i,1) =~ /^[<>]$/) {
  480.             substr($_,$i,1) = 'b';
  481.             }
  482.         }
  483.         elsif ($c eq '[' && !$repl) {
  484.             $i++ if substr($_,$i,1) eq '^';
  485.             $i++ if substr($_,$i,1) eq ']';
  486.             $inbracket = 1;
  487.         }
  488.         elsif ($c eq ']') {
  489.             $inbracket = 0;
  490.         }
  491.         elsif ($c eq "\t") {
  492.             substr($_, $i, 1) = '\\t';
  493.             $i++;
  494.             $len++;
  495.         }
  496.         elsif (!$repl && index("()+",$c) >= 0) {
  497.             substr($_, $i, 0) = '\\';
  498.             $i++;
  499.             $len++;
  500.         }
  501.         }
  502.         &Die("Malformed substitution at line $.\n")
  503.           unless $end;
  504.         $pat = substr($_, 0, $repl + 1);
  505.         $repl = substr($_, $repl+1, $end-$repl-1);
  506.         $end = substr($_, $end + 1, 1000);
  507.         &simplify($pat);
  508.         $dol = '$';
  509.         $repl =~ s/\$/\\$/;
  510.         $repl =~ s'&'$&'g;
  511.         $repl =~ s/[\\]([0-9])/$dol$1/g;
  512.         $subst = "$pat$repl$delim";
  513.         $cmd = '';
  514.         while ($end) {
  515.         if ($end =~ s/^g//) {
  516.             $subst .= 'g';
  517.             next;
  518.         }
  519.         if ($end =~ s/^p//) {
  520.             $cmd .= ' && (print)';
  521.             next;
  522.         }
  523.         if ($end =~ s/^w[ \t]*//) {
  524.             $fh = &make_filehandle($end);
  525.             $cmd .= " && (print $fh \$_)";
  526.             $end = '';
  527.             next;
  528.         }
  529.         &Die("Unrecognized substitution command".
  530.           "($end) at line $.\n");
  531.         }
  532.         chop ($_ = &q(<<"EOT"));
  533. :    <<--#ifdef TSEEN
  534. :    $subst && \$tflag++$cmd;
  535. :    <<--#else
  536. :    $subst$cmd;
  537. :    <<--#endif
  538. EOT
  539.         next;
  540.     }
  541.  
  542.     if (/^p/) {
  543.         $_ = 'print;';
  544.         next;
  545.     }
  546.  
  547.     if (/^w/) {
  548.         s/^w[ \t]*//;
  549.         $fh = &make_filehandle($_);
  550.         $_ = "print $fh \$_;";
  551.         next;
  552.     }
  553.  
  554.     if (/^r/) {
  555.         $appendseen++;
  556.         s/^r[ \t]*//;
  557.         $file = $_;
  558.         $_ = "\$atext .= `cat $file 2>/dev/null`;";
  559.         next;
  560.     }
  561.  
  562.     if (/^P/) {
  563.         $_ = 'print $1 if /^(.*)/;';
  564.         next;
  565.     }
  566.  
  567.     if (/^D/) {
  568.         chop($_ = &q(<<'EOT'));
  569. :    s/^.*\n?//;
  570. :    redo LINE if $_;
  571. :    next LINE;
  572. EOT
  573.         $sawnext++;
  574.         next;
  575.     }
  576.  
  577.     if (/^N/) {
  578.         chop($_ = &q(<<'EOT'));
  579. :    $_ .= "\n";
  580. :    $len1 = length;
  581. :    $_ .= <>;
  582. :    chop if $len1 < length;
  583. :    <<--#ifdef TSEEN
  584. :    $tflag = 0;
  585. :    <<--#endif
  586. EOT
  587.         next;
  588.     }
  589.  
  590.     if (/^h/) {
  591.         $_ = '$hold = $_;';
  592.         next;
  593.     }
  594.  
  595.     if (/^H/) {
  596.         $_ = '$hold .= "\n"; $hold .= $_;';
  597.         next;
  598.     }
  599.  
  600.     if (/^g/) {
  601.         $_ = '$_ = $hold;';
  602.         next;
  603.     }
  604.  
  605.     if (/^G/) {
  606.         $_ = '$_ .= "\n"; $_ .= $hold;';
  607.         next;
  608.     }
  609.  
  610.     if (/^x/) {
  611.         $_ = '($_, $hold) = ($hold, $_);';
  612.         next;
  613.     }
  614.  
  615.     if (/^b$/) {
  616.         $_ = 'next LINE;';
  617.         $sawnext++;
  618.         next;
  619.     }
  620.  
  621.     if (/^b/) {
  622.         s/^b[ \t]*//;
  623.         $lab = &make_label($_);
  624.         if ($lab eq $toplabel) {
  625.         $_ = 'redo LINE;';
  626.         } else {
  627.         $_ = "goto $lab;";
  628.         }
  629.         next;
  630.     }
  631.  
  632.     if (/^t$/) {
  633.         $_ = 'next LINE if $tflag;';
  634.         $sawnext++;
  635.         $tseen++;
  636.         next;
  637.     }
  638.  
  639.     if (/^t/) {
  640.         s/^t[ \t]*//;
  641.         $lab = &make_label($_);
  642.         $_ = q/if ($tflag) {$tflag = 0; /;
  643.         if ($lab eq $toplabel) {
  644.         $_ .= 'redo LINE;}';
  645.         } else {
  646.         $_ .= "goto $lab;}";
  647.         }
  648.         $tseen++;
  649.         next;
  650.     }
  651.  
  652.     if (/^y/) {
  653.         s/abcdefghijklmnopqrstuvwxyz/a-z/g;
  654.         s/ABCDEFGHIJKLMNOPQRSTUVWXYZ/A-Z/g;
  655.         s/abcdef/a-f/g;
  656.         s/ABCDEF/A-F/g;
  657.         s/0123456789/0-9/g;
  658.         s/01234567/0-7/g;
  659.         $_ .= ';';
  660.     }
  661.  
  662.     if (/^=/) {
  663.         $_ = 'print $.;';
  664.         next;
  665.     }
  666.  
  667.     if (/^q/) {
  668.         chop($_ = &q(<<'EOT'));
  669. :    close(ARGV);
  670. :    @ARGV = ();
  671. :    next LINE;
  672. EOT
  673.         $sawnext++;
  674.         next;
  675.     }
  676.     } continue {
  677.     if ($space) {
  678.         s/^/$space/;
  679.         s/(\n)(.)/$1$space$2/g;
  680.     }
  681.     last;
  682.     }
  683.     $_;
  684. }
  685.  
  686. sub fetchpat {
  687.     local($outer) = @_;
  688.     local($addr) = $outer;
  689.     local($inbracket);
  690.     local($prefix,$delim,$ch);
  691.  
  692.     # Process pattern one potential delimiter at a time.
  693.  
  694.     DELIM: while (s#^([^\]+(|)[\\/]*)([]+(|)[\\/])##) {
  695.     $prefix = $1;
  696.     $delim = $2;
  697.     if ($delim eq '\\') {
  698.         s/(.)//;
  699.         $ch = $1;
  700.         $delim = '' if $ch =~ /^[(){}A-Za-mo-z]$/;
  701.         $ch = 'b' if $ch =~ /^[<>]$/;
  702.         $delim .= $ch;
  703.     }
  704.     elsif ($delim eq '[') {
  705.         $inbracket = 1;
  706.         s/^\^// && ($delim .= '^');
  707.         s/^]// && ($delim .= ']');
  708.     }
  709.     elsif ($delim eq ']') {
  710.         $inbracket = 0;
  711.     }
  712.     elsif ($inbracket || $delim ne $outer) {
  713.         $delim = '\\' . $delim;
  714.     }
  715.     $addr .= $prefix;
  716.     $addr .= $delim;
  717.     if ($delim eq $outer && !$inbracket) {
  718.         last DELIM;
  719.     }
  720.     }
  721.     $addr =~ s/\t/\\t/g;
  722.     &simplify($addr);
  723.     $addr;
  724. }
  725.  
  726. sub q {
  727.     local($string) = @_;
  728.     local($*) = 1;
  729.     $string =~ s/^:\t?//g;
  730.     $string;
  731. }
  732.  
  733. sub simplify {
  734.     $_[0] =~ s/_a-za-z0-9/\\w/ig;
  735.     $_[0] =~ s/a-z_a-z0-9/\\w/ig;
  736.     $_[0] =~ s/a-za-z_0-9/\\w/ig;
  737.     $_[0] =~ s/a-za-z0-9_/\\w/ig;
  738.     $_[0] =~ s/_0-9a-za-z/\\w/ig;
  739.     $_[0] =~ s/0-9_a-za-z/\\w/ig;
  740.     $_[0] =~ s/0-9a-z_a-z/\\w/ig;
  741.     $_[0] =~ s/0-9a-za-z_/\\w/ig;
  742.     $_[0] =~ s/\[\\w\]/\\w/g;
  743.     $_[0] =~ s/\[^\\w\]/\\W/g;
  744.     $_[0] =~ s/\[0-9\]/\\d/g;
  745.     $_[0] =~ s/\[^0-9\]/\\D/g;
  746.     $_[0] =~ s/\\d\\d\*/\\d+/g;
  747.     $_[0] =~ s/\\D\\D\*/\\D+/g;
  748.     $_[0] =~ s/\\w\\w\*/\\w+/g;
  749.     $_[0] =~ s/\\t\\t\*/\\t+/g;
  750.     $_[0] =~ s/(\[.[^]]*\])\1\*/$1+/g;
  751.     $_[0] =~ s/([\w\s!@#%^&-=,:;'"])\1\*/$1+/g;
  752. }
  753.  
  754.